perm filename RVRS.F4[MSS,LCS]1 blob sn#186053 filedate 1975-11-11 generic text, type T, neo UTF8
00100		SUBROUTINE RVRS(IT)
00200		COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
00300		K=1
00400	
00500	1	J=KPN(K)
00600		R=Q(J+1)
00700		IF(R.NE.1)GO TO 2
00800	C  JUMP IF NOT A NOTE
00900		IF(Q(J+5).LT.10)GO TO 10
01000	C  JUMP IF NO STEM ON IT
01100		KK=K+1
01200	3	IF(KK.GT.IT)RETURN
01300		JJ=KPN(KK)
01400		RR=Q(JJ+1)
01500		IF(RR.NE.1)GO TO 5
01600	C  JUMP IF NOT A NOTE
01700		IF(Q(JJ+5).GE.10)GO TO 6
01800	C SKIP CHORD NOTES (NO STEM)
01900	7	KK=KK+1
02000		GO TO 3
02100	C DID NOT FIND BEAM NEARBY
02200	6	RZ=AMOD(Q(J+4),100.0)
02300		N=J+5
02400		A=10
02500		IF(RZ.GE.7)GO TO 60
02510		IF(Q(N).LT.20)GO TO 10
02515	C NOW STEM SHOULD BE DOWN IF WITHOUT BEAM OR 1ST NT UNDER BEAM.
02520		A=-A
02530		GO TO 15
02700	60	IF(Q(N).GE.20)GO TO 10
02710	C  THERE MUST BE A BETTER WAY!
02800	15	Q(N)=Q(N)+A
02900		GO TO 10
03000	8	IF(Q(N).LT.20)GO TO 10
03100		A=-A
03200	C  STEM UP
03300		GO TO 15
03400	5	IF(RR.NE.6)GO TO 6
03500	20	B=Q(JJ+4)
03600		C=Q(JJ+5)
03700		D=(B+C)/2.
03800		IF(RR.EQ.5)GO TO 9
03900		IF(RR.NE.6)GO TO 10
04000		B=Q(JJ+6)+1.
04050	C  SAVES RANGE OF BEAM +1.
04100		IF(Q(JJ+7).GE.20)GO TO 11
04200	C  NOW STEMS ARE UP
04300		IF(D.LE.7)GO TO 12
04400	C JUMP TO 12 IF ALL OK
04500	CC	C=-10
04600		GO TO 23
04700	11	IF(D.GT.7.)GO TO 12
04800	C  STEMS DOWN
04900	C JUMP IF NO REVERSE NEEDED
05000	23	DO 16 N=K,IT
05100		KK=KPN(N)
05200		IF(Q(KK+3).GT.B)GO TO 14
05300		R=Q(KK+1)
05400		IF(R.NE.1)GO TO 17
05500		L=5
05520		R=Q(KK+8)
05540	C  THE STEM LENGTH
05560		IF(R.EQ.999)GO TO 19
05580		Q(KK+8)=-R
05600	C  FOR THE INVERSION
05700	19	C=10.
05710		A=Q(KK+L)
05800		IF(A.GE.20)C=-C
05900		Q(KK+L)=C+A
06000		GO TO 16
06100	17	IF(R.NE.6)GO TO 18
06200	C NOW IT'S A BEAM
06300		L=7
06400		GO TO 19
06500	18	IF(R.NE.5)GO TO 16
06600	C NOW IT'S A SLUR
06610		C=-3.5
06620		IF(Q(KK+7))C=-C
06640		CALL SLRV(KK,C)
06650	C  TO REVERSE SLUR
06700	CC	Q(KK+7)=-Q(KK+7)
06800	16	CONTINUE
06900	C  SHOULD ALWAYS EXIT FROM LOOP BEFORE END OF ARRAY!
07000	
07100	
07200	C NEXT FOR SLURS
07400	9	B=-3.5
07500		IF(Q(JJ+7))GO TO 24
07600		IF(D.GT.7)GO TO 10
07700	C JUMP TO LEAVE STEM UP
07800		GO TO 25
07900	24	IF(D.LT.5)GO TO 10
08000	C JUMP TO LEAVE STEM DOWN
08100		B=-B
08200	CC25	Q(JJ+4)=Q(JJ+4)+B
08300	CC	Q(JJ+5)=Q(JJ+5)+B
08400	CC	Q(JJ+7)=-R
08410	25	CALL SLRV(JJ,B)
08500		GO TO 10
08600	12	DO 13 N=K+1,IT
08700		KK=KPN(N)
08800	13	IF(Q(KK+3).GT.B)GO TO 14
08900	C  JUMP OUT WHEN PAST END OF BEAM.
09000	14	K=N-1
09100		GO TO 10
09200	
09300	2	IF(R.NE.6)GO TO 21
09400	22	JJ=J
09500		RR=R
09600		GO TO 20
09700	21	IF(R.EQ.5)GO TO 22
09800	10	IF(K.GT.IT)RETURN
09900		K=K+1
10000		GO TO 1
10100		END